Pascal Super Library/Pascal Super Library (CW International)(1997).bin/LIBRARY/PRUS101/FTVPRINT.PAS

Pascal/Delphi Source File | 1994-12-20 | 9KB | 488 lines

unit FTVPRINT;

 { FIDO unit to use different Printer with ONE Unit + Driver
   running under Turbo Vision
 (*************************************************************************)

     RELEASE 1.00 - as first contained in the file PRUS???.LZH
        by Matthias Tichy, 2:2440/210.14, GERMANY

           --------------------------------------------
        organized for Fido's PASCAL related echoes
           --------------------------------------------

     15/08/1994 to --/--/---- by Matthias Tichy, 2:2440/210.14, GERMANY


       As far as third party copyrights are not violated this
       source code is hereby placed to the public domain. Use
       it whatever way you want, but use AT YOUR OWN RISK.

       In case you should modify the source rather send your
       modifications to the unit's current organizer (see above for
       NM address) than to spread it on your own. This will help to
       keep the unit updated and grant a certain standard to all
       other users as well.

       The unit is currently still under work. So it might greatly
       benefit of your participation.

       Those who contributed to the following piece of source,
       listed in alphabethical order:
    ================================================================
        Matthias Tichy ...
    ================================================================
       YOUR NAME WILL APPEAR HERE IF YOU CONTRIBUTE USEFUL SOURCE.

       Credits in your own programs are as welcome as unnecessary.

(***************************************************************************}

{$I FDEFINE.DEF} { Use the general include file for conditional defines and
        y   common compiler directives ... }

         { ... and set the unit's specific defines aftwerwards. }

interface

uses dos, printer, msgbox;

const
  FPrinter : Byte = 1;
  {$ifdef English}
  fxxx : array[1..1] of string = ('Printer');
  {$endif}
  {$ifdef German}
  fxxx : array[1..1] of string = ('Drucker');
  {$endif}

type
  PParameter = ^TParameter;
  TParameter = array[1..10] of Byte;

  PTreiber = ^TTreiber;
  TTreiber = array[1..30] of Char;

var
  Printer_fault : byte;
  f : text;
  treiber_datei : string;
  Parameter : PParameter;
  Treiber : PTreiber;
  oldint24 : pointer;
  newint24 : pointer;

procedure init;
procedure done;

procedure setTDT(datei : string);
function CheckTDT(datei : string) : boolean;
function GetPrinter(datei :string) : string;

function getfault : byte;
procedure Error(object_id, code : byte);

procedure laden(nr : byte);
procedure ausgeben;

procedure printeln(text : string);
procedure print(text : string);
procedure cr;
procedure lf;
procedure ff;

procedure PrinterInit;
procedure BoldOn;
procedure BoldOff;
procedure ItalicOn;
procedure ItalicOff;
procedure UnderLinedOn;
procedure UnderLinedOff;
procedure BreitOn;
procedure BreitOff;
procedure SchmalOn;
procedure SchmalOff;
procedure HighOn;
procedure HighOff;
procedure LowOn;
procedure LowOff;

{ allgemeine Routinen }

function FileExists(FileName: string; attr : Word) : Boolean;
function getpartstring(text : string; anfang, ende : char) : string;
function Byte2Str(Zahl : Byte) : string;

implementation

procedure Init;

begin
  New(Parameter);
  New(treiber);
end;

procedure Done;

begin
  Dispose(Parameter);
  Dispose(Treiber);
end;

procedure setTDT(datei : string);

begin
  treiber_datei := datei;
  if not fileExists(treiber_datei, anyfile) then error(FPrinter, 1);
  Assign(f, treiber_datei);
end;

function CheckTDT(datei :string) : boolean;

var dat : text;
    Zeile : string;

begin
  CheckTDT := false;
  assign(dat, datei);
  reset(dat);
  readln(dat, Zeile);
  if Zeile = 'TDT' then CheckTDT := true;
  close(dat);
end;

function GetPrinter(datei :string) : string;

var dat : text;
    Zeile : string;

begin
  assign(dat, datei);
  reset(dat);
  repeat
    readln(dat, Zeile);
  until copy(Zeile,1,2) = 'N)';
  getPrinter := copy(Zeile, 4, length(Zeile)-4);
  close(dat);
end;

function getfault : byte;

begin
  Printer_fault := ioresult;
  if Printer_fault <> 0 then Error(FPrinter, Printer_fault);
  getfault := Printer_fault;
end;

procedure Error(object_id, code : Byte);

var
  meldung : string;

begin
  case code of
    151 : meldung := 'Bitte stecken Sie den Drucker an die parallele Schnittstelle an,'+#13+
                     'schalten ihn an und auf on-line';
    159 : meldung := 'Das Papier ist zu Ende. Bitte füllen Sie Neues nach.';
    160 : meldung := 'Der Drucker ist auf off-line. Schalten Sie ihn bitte auf on-line';
    else  meldung := 'Unbekannter Drucker-Fehler Nr: '+ byte2str(code);
  end;
  messagebox(meldung, nil, mfOkButton);
end;

procedure setparameter(index, Text : byte);

begin
  Parameter^[index] := text;
end;

procedure laden(nr :Byte);

var
  punkt : LongInt;
  buf : String;
  ch : string;
  dummy : string;
  para : Char;
  tester : boolean;
  param : Byte;

  function getchar : char;

  var temp : string;
      dummy : Byte;
      i : Byte;
      code : Integer;

  begin
    buf := removeleft(') ',buf);
    buf := removeright('; ',buf);
    if buf = '' then
      begin
        getChar := #255;
        exit;
      end;
    temp := buf;
    i := 1;
    while (not (temp[i] in ['#','$','n'])) and not (i>length(temp)) do inc(i);
    if temp[length(temp)] <> ' ' then temp := temp + ' ';
    temp := getpartstring(temp,temp[i],' ');
    case temp[1] of
      '#' : begin
              i := 2;
              if temp[length(temp)] <> ' ' then temp := temp + ' ';
              val(copy(temp,2,length(temp)-2),dummy,code);
              getChar := char(dummy);
            end;
      'n' : begin
              getChar := char(parameter^[param]);
              inc(param);
            end;
      ' ' : begin
              getChar := #255;
            end;
    end;
    i := pos(' ',buf);
    buf := copy(buf, i, length(buf)-i+1);
    if i = 0 then buf := '';
  end;

begin
  for punkt := 1 to 35 do treiber^[punkt] := #255;
  param := 1;
  str(nr,ch);
  reset(f);
  tester := false;
  repeat
    readln(f, buf);
    dummy := buf;
    buf := removeLeft(' ',buf);
    buf := copy(buf, 1, pos(')',buf)-1);
    if buf = ch then tester := true;
    buf := dummy;
  until tester = true or eof(f);
  if eof(f) and not tester then
    begin
      writeln('Fehler in Druckertreiber bei Nr :', nr, '!!');
      halt;
    end;
  buf := getpartstring(buf,')',';');
  punkt := 1;
  repeat
    para := getChar;
    if para <> #255 then Treiber^[punkt] := para;
    inc(punkt);
  until para = #255;
  close(f);
end;

{$I-}
procedure ausgeben;

var
  index : byte;

begin
  getintvec($24,newint24);
  setintvec($24,oldint24);
  for index := 1 to 35 do if Treiber^[index] <> chr(255) then
    begin
      repeat;
        write(lst,Treiber^[index]);
      until getfault = 0;
    end;
  SetIntVec($24, newInt24);
end;

procedure printeln(text : string);

var i : Byte;

begin
  getintvec($24,newint24);
  setintvec($24,oldint24);
  repeat;
  writeln(lst,text);
  until getfault = 0;
  SetIntVec($24, newInt24);
end;

procedure print(Text : string);

var i : Byte;

begin
  getintvec($24,newint24);
  setintvec($24,oldint24);
  repeat;
  write(lst,text);
  until getfault = 0;
  SetIntVec($24, newInt24);
end;

{$I+}

procedure PrinterInit;

begin
  laden(1);
  ausgeben;
end;

procedure BoldOn;

begin
  laden(2);
  ausgeben;
end;

procedure BoldOff;

begin
  laden(3);
  ausgeben;
end;

procedure ItalicOn;

begin
  laden(8);
  ausgeben;
end;

procedure ItalicOff;

begin
  laden(9);
  ausgeben;
end;

procedure UnderLinedOn;

begin
  laden(4);
  ausgeben;
end;

procedure UnderLinedOff;

begin
  laden(5);
  ausgeben;
end;

procedure cr;

begin
  repeat
    write(lst, #13);
  until getfault = 0;
end;

procedure lf;

begin
  repeat
    write(lst, #10);
  until getfault = 0;
end;

procedure ff;

begin
  repeat
    write(lst, #12);
  until getfault = 0;
end;

procedure BreitOn;

begin
  laden(6);
  ausgeben;
end;

procedure BreitOff;

begin
  laden(7);
  ausgeben;
end;

procedure SchmalOn;

begin
  laden(14);
  ausgeben;
end;

procedure SchmalOff;

begin
  laden(15);
  ausgeben;
end;

procedure HighOn;

begin
  laden(10);
  ausgeben;
end;

procedure HighOff;

begin
  laden(11);
  ausgeben;
end;

procedure LowOn;

begin
  laden(12);
  ausgeben;
end;

procedure LowOff;

begin
  laden(13);
  ausgeben;
end;

function FileExists(FileName: string; attr : Word) : Boolean;

var
  f: SearchRec;

begin
  findfirst(Filename, attr, f);
  if doserror = 0 then Fileexists := true else Fileexists := false;
end;

function getpartstring(text : string; anfang, ende : char) : string;

var temp : string;
    punkt : Byte;

begin
  punkt := pos(anfang,text);
  temp  := copy(text,punkt,length(text)-punkt);
  punkt := pos(ende,temp);
  temp  := copy(temp,1,punkt);
  getpartstring := temp;
end;

function Byte2Str(Zahl : Byte) : string;

var dummy : string;

begin
  Str(Zahl,dummy);
  Byte2Str := dummy;
end;

begin
  getIntVec($24, oldint24);
end.